home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / tls / tls074c.sunsparc.Z / tls074c.sunsparc / lib / vtcl / vtcl.tlib < prev    next >
Encoding:
Text File  |  1995-07-20  |  30.7 KB  |  1,143 lines
  1. #@package: VisualTclX-menu VxMenu VxMenuGetButton VxOptionMenu \
  2.     VxOptionMenuGetSelected VxOptionMenuReplaceOptions VxOptionMenuSetSelected
  3. #
  4. # Menu creation routines
  5. #
  6. #
  7. # VxMenu 
  8. #        builds the insides of a menu bar, Uset VxMenuGetButton to get
  9. #         the reference to a menu item widget, ie VxMenuGetButton $dlog "New"
  10. #
  11. # Syntax:
  12. #           VxMenu formDialog menuBar menuList defaultCB
  13. #
  14. # Arguments:
  15. #       formDialog      - widgetName of form dialog
  16. #    menuBar     - widgetName of menubar
  17. #    menuList    - menu list to build from
  18. #    defaultCB    - default callback to call if they aren't set 
  19. #              in menuList
  20. #
  21. #
  22. #     each item in menulist can contain the following indices
  23. #        OFFSET        Description
  24. #        -----        -----------
  25. #          0        Type, one of following pd, hp, cs, bt, sp,
  26. #                   sp, tb, sc
  27. #          1        Name, name of the button
  28. #          2        mnemonic
  29. #          3        accelerator
  30. #          4        acceleratorString
  31. #          5        callback to associate with button
  32. #          6        If a toggle button this sets the initial state
  33. #
  34. # Use VxMenuGetButton to get the buttons in the menu.
  35. #
  36. proc VxMenu {dlog menubar menuList defaultCB} {
  37.     # different codes for various objects, the only one that is non
  38.     # obvious here is cs, it stands for cascade.
  39.     keylset typeKey pd VtPulldown     hp VtPulldown     cs VtPulldown \
  40.               bt VtPushButton    sp VtSeparator    tb VtToggleButton \
  41.             sc EndCascade
  42.  
  43.     set cascadeStack ""
  44.     foreach m  $menuList {
  45.  
  46.     set type [lindex $m 0]
  47.     set cmd [keylget typeKey $type]
  48.     set label [lindex $m 1]
  49.     
  50.     # convert the ellipses to '+'
  51.     set name [translit ". " "+_" $label]
  52.  
  53.     switch $type {
  54.         pd - hp {
  55.         # Creating a pulldown menu
  56.         lappend cmd "$menubar.$name"
  57.         }
  58.         sc {
  59.         # closing a cascade, pop the last pulldown off the stac
  60.         set lastPd [lvarpop cascadeStack]
  61.         continue
  62.         }
  63.         sp {
  64.         lappend cmd "$lastPd.$name" -allowDuplicateName
  65.         eval $cmd
  66.         continue
  67.         }
  68.         default {
  69.         lappend cmd "$lastPd.$name"
  70.         }
  71.     }
  72.  
  73.     # This is a help pulldown
  74.     if {$type == "hp"} { lappend cmd -help }
  75.  
  76.     # set the label
  77.     lappend cmd -label $label
  78.        
  79.  
  80.     # now set the various placement dependant options
  81.     if { [lindex $m 2] != ""} {
  82.         lappend cmd -mnemonic [lindex $m 2 ]
  83.     }
  84.  
  85.     if { [lindex $m 3] != ""}  {
  86.         lappend cmd  -accelerator [lindex $m 3]
  87.     }
  88.  
  89.     if { [lindex $m 4] != ""} {
  90.         lappend cmd -acceleratorString [lindex $m 4]
  91.     }
  92.  
  93.     set cb [lindex $m 5]
  94.     if {$cb != ""} {
  95.         lappend cmd -callback $cb
  96.     } elseif {$type != "pd" && $type != "hp" && $type != "cs"} {
  97.         lappend cmd -callback $defaultCB
  98.     }
  99.  
  100.     # Toggle buttons have a 6th option, the initial set state
  101.     if { $type == "tb" && [lindex $m 6] != "" } {
  102.         lappend cmd -value [lindex $m 6]
  103.     }
  104.  
  105.     
  106.     switch $type {
  107.         pd - hp {
  108.         set lastPd [eval $cmd]
  109.         VxSetVar $dlog MenuButton($label) $lastPd
  110.         }
  111.         cs {
  112.         set cascade [eval $cmd]
  113.         lvarpush cascadeStack $lastPd
  114.         set lastPd $cascade
  115.          VxSetVar $dlog MenuButton($label) $lastPd
  116.         }
  117.         default {
  118.         set but [eval $cmd]
  119.  
  120.         VxSetVar $dlog MenuButton($label) $but
  121.         }
  122.     }
  123.     }
  124. }
  125.  
  126. #
  127. #VxMenuGetButton
  128. #    Gets the widget name of a button in a menu created with VxMenu
  129. #
  130. #Syntax:
  131. #    VxMenuGetButton widgetName buttonLabel
  132. #
  133. #Arguments:
  134. #    widgetName    - Widget name of the menu created by VxMenu
  135. #    buttonLabel     - label of the button to retrieve
  136. #
  137. proc VxMenuGetButton {dlog name} {
  138.     return [VxGetVar $dlog MenuButton($name)]
  139. }
  140.  
  141.  
  142. #------------------------------------------------------------
  143. #
  144. # Routines for option menus
  145. #
  146. #
  147. # VxOptionMenu object.name label options defaultCB selection
  148. #
  149. #       Returns an option menu that contains pushbuttons for the
  150. #       options specified.
  151. #
  152. #    object.name     - widget hierarchy of option menu
  153. #       label           - option menu label, 
  154. #                 (e.g. "filename:")
  155. #       options         - tcl list of options 
  156. #              (to be used as labels for the pushbuttons) 
  157. #                  (e.g. {one two three})
  158. #       defaultCB       - callback called when option menu changes
  159. #       selection       - option which is initially selected
  160. #                         (e.g. "one")
  161. #
  162. #
  163. # VxOptionMenuGetSelected menu 
  164. #
  165. #       Returns the label of the selected item in an option menu that
  166. #       was created by VxOptionMenu
  167. #
  168. #       widgetName       - name of menu returned by VxOptionMenu
  169. #
  170. # VxOptionMenuSetSelected menu selection
  171. #
  172. #       Sets the option menu's value to be <selection>. "selection" refers
  173. #       to the label of the selected pushbutton.  The option menu 
  174. #       referenced must have been created by VxOptionMenu.
  175. #
  176. #       widgetName       - name of menu returned by VxOptionMenu
  177. #       selection        - label of option to be selected.
  178. #
  179. #
  180. # VxOptionMenuReplaceOptions widgetName options selection
  181. #
  182. #           Returns the label of the selected item in an option menu that
  183. #
  184. #       widgetName      - name of menu returned by VxOptionMenu
  185. #       options         - tcl list of options 
  186. #              (to be used as labels for the pushbuttons) 
  187. #                  (e.g. {one two three})
  188. #       selection       - option which is initially selected
  189. #                         (e.g. "one")
  190. #
  191. #
  192.  
  193. proc _SetOptions {menu options selection} {
  194.     #
  195.     # make option menu buttons and assign to userdata
  196.     set i 0
  197.     foreach buttonLabel $options {
  198.         set button [VtPushButton $menu.button$i -label $buttonLabel]
  199.         keylset allButtons button$i $buttonLabel
  200.         incr i
  201.     }
  202.     if {![info exists allButtons]} {
  203.         VtSetValues $menu -userData {}
  204.         return $menu
  205.     } else {
  206.         keylset allButtons ":labelList" $options
  207.         VtSetValues $menu -userData $allButtons
  208.     }
  209.  
  210.  
  211.     if {$selection == "" } {
  212.         #set to the first one
  213.         VtSetValues $menu -selectedWidget $menu.button0
  214.     } else {
  215.         VxOptionMenuSetSelected $menu $selection
  216.     }
  217. }
  218.  
  219.  
  220. proc VxOptionMenu {name label options CB selection} {
  221.     set menu [VtOptionMenu $name -label $label]
  222.     if {$CB != ""} {
  223.         VtSetValues $menu -callback $CB
  224.     }
  225.  
  226.     _SetOptions $menu $options $selection 
  227.     return $menu
  228. }
  229.  
  230. proc VxOptionMenuGetSelected {menu} {
  231.     set selectedWidget [VtGetValues $menu -selectedWidget]
  232.     set allButtons [VtGetValues $menu -userData]
  233.     set button [VxGetShortName $selectedWidget]
  234.     return [keylget allButtons $button]
  235. }
  236.  
  237. proc VxOptionMenuSetSelected {menu selected} {
  238.     set allButtons [VtGetValues $menu -userData]
  239.     set labelList [keylget allButtons ":labelList"]
  240.     set button [lsearch $labelList $selected]
  241.     if {$button == -1} {
  242.         error "VxOptionMenuSetSelected: selection invalid: $selected"
  243.     }
  244.  
  245.     VtSetValues $menu -selectedWidget $menu.button$button
  246. }
  247.  
  248. proc VxOptionMenuReplaceOptions {menu options selection} {
  249.         #
  250.     # get button list
  251.     set allButtons [VtGetValues $menu -userData]
  252.  
  253.     #
  254.     # destroy old buttons
  255.     if {$allButtons != "{}"} {
  256.             foreach button [keylkeys allButtons] {
  257.              if {$button != ":labelList"} {
  258.                  VtDestroy $menu.$button
  259.              }
  260.         }
  261.     }
  262.  
  263.     #
  264.     # make new buttons
  265.     _SetOptions $menu $options $selection
  266. }
  267.  
  268. #@packend
  269.  
  270.  
  271. #@package: VisualTclX-label VxList VxText VxRowColumn VxRadioBox \
  272.     VxCheckBox VxComboBox      
  273.  
  274. #
  275. # The following five routines add the -label -title functionality to 
  276. # VtList VtText VtRowColumn VtRadioBox VtCheckBox
  277. #
  278.  
  279. proc VxList {name args} {
  280.     eval _VxBox VtList $name $args
  281. }
  282.  
  283. proc VxText {name args} {
  284.     eval _VxBox VtText $name $args
  285. }
  286.  
  287. proc VxRadioBox {name args} {
  288.     eval _VxBox VtRadioBox $name $args
  289. }
  290.  
  291. proc VxCheckBox {name args} {
  292.     eval _VxBox VtCheckBox $name $args
  293. }
  294.  
  295. proc VxRowColumn {name args} {
  296.     eval _VxBox VtRowColumn $name $args
  297. }
  298.  
  299. proc VxComboBox {name args} {
  300.     eval _VxBox VtComboBox $name $args
  301. }
  302.  
  303. proc _VxBox {cmd name args} {
  304.     set parts [split $name .]
  305.     set wName [lindex $parts end]
  306.  
  307.     # delete name 
  308.     set parts [lreplace $parts end end]  
  309.     set parent [join $parts .]
  310.  
  311.     # list of options that we are going to override, if any
  312.     # of the geometry options are set, we need to set them on the
  313.     # invisible form.
  314.     set geoOptions {}
  315.     foreach opt {
  316.       leftOffset leftSide  alignLeft
  317.       rightOffset rightSide alignRight
  318.       topOffset topSide alignTop
  319.       bottomOffset bottomSide alignBottom
  320.       below above
  321.     } {
  322.       lappend geoOptions -$opt -MOTIF_$opt -CHARM_$opt
  323.     }
  324.   
  325.     # These two options are the ones that we are really interested in
  326.  
  327.     # These two options are the ones that we are really interested in
  328.     # if either one of these two exist we create a form wrapper around
  329.     # the object.
  330.     set allOptions [concat $geoOptions "-title -label"]
  331.     
  332.     foreach opt $allOptions {
  333.     set found($opt) ""
  334.     }
  335.  
  336.     set lastFound ""
  337.     set newArgs ""
  338.     foreach arg $args {
  339.  
  340.     if {$lastFound != ""} {
  341.         set found($lastFound) $arg
  342.         set lastFound ""
  343.         continue
  344.     }
  345.  
  346.     set lastFound [lmatch -exact $allOptions $arg]
  347.     if {$lastFound != ""} {
  348.         continue
  349.     }
  350.  
  351.     lappend newArgs $arg
  352.     }
  353.  
  354.     # Create the args list for the outer form
  355.     set boxArgs ""
  356.     foreach opt $geoOptions {
  357.     if {$found($opt) != ""} {
  358.         lappend boxArgs $opt $found($opt)
  359.     }
  360.     }
  361.  
  362.     set form $parent
  363.     if {$found(-title) != "" || $found(-label) != ""} {
  364.     # make the form
  365.     set boxname  [format "%s_box" $wName]
  366.  
  367.     set form     [eval VtForm $parent.$boxname $boxArgs\
  368.                            -marginHeight 0 -marginWidth 0]
  369.  
  370.     if {$found(-title) != ""} {
  371.         set label    [VtLabel $form.label -label $found(-title) \
  372.                  -topSide FORM]
  373.           set target   [eval $cmd $form.$wName $newArgs -topSide $label \
  374.                -leftSide FORM -rightSide FORM -bottomSide FORM]
  375.     } else {
  376.         set label    [VtLabel $form.label -label $found(-label) \
  377.                           -topSide FORM -bottomSide FORM]
  378.           set target   [eval $cmd $form.$wName $newArgs \
  379.                      -leftSide $label -leftOffset 5 \
  380.                     -rightSide FORM \
  381.                      -topSide FORM -bottomSide FORM]
  382.     }
  383.  
  384.         VxSetVar $target "form" $form
  385.         VxSetVar $target "label" $label
  386.  
  387.     } else {
  388.     set target [eval $cmd $form.$wName $newArgs $boxArgs]
  389.     }
  390.  
  391.     return $target
  392. }
  393.  
  394.  
  395. #@packend
  396.  
  397. #@package:  VisualTclX-align VxAlignBaseLines VxCenterVertically \
  398.     VxSetLeftOffsets VxAlignedForm
  399.  
  400. #================================================================== API ===
  401. # VxAlignBaseLines
  402. #
  403. #       Given two widgets which have been created with the sourceWidget
  404. #    -alignTop to the targetWidget, sets the top offset of the sourceWidget
  405. #    so that its baseline lines up with the targetWidget's baseline.
  406. #
  407. # Parameters:
  408. #    targetWidget  - the widget you are aligning to
  409. #    sourceWidget  - the widget that will be adjusted
  410. #    currentOffset - any topOffset the targetWidget already has which must
  411. #            be taken into account (OPTIONAL, default=0)
  412. # Globals:
  413. # Returns:
  414. #--------------------------------------------------------------------------
  415. proc VxAlignBaseLines {targetWidget sourceWidget {currentOffset 0}} {
  416.     set source [VtGetValues $sourceWidget -baseLineList]
  417.     set target [VtGetValues $targetWidget -baseLineList]
  418.     set diff [expr {($target - $source) + $currentOffset}]
  419.     VtSetValues $sourceWidget -MOTIF_topOffset $diff
  420. }
  421.  
  422. #================================================================== API ===
  423. # VxCenterVertically
  424. #
  425. #       Given two widgets which have been created with the sourceWidget
  426. #    -alignTop to the targetWidget, sets the top offset of the sourceWidget
  427. #    so that the targetWidget is in the center.
  428. #
  429. # Parameters:
  430. #    targetWidget - the widget you are centering around
  431. #    sourceWidget - the widget that will be adjusted
  432. # Globals:
  433. # Returns:
  434. #--------------------------------------------------------------------------
  435. proc VxCenterVertically {targetWidget sourceWidget} {
  436.     set source [VtGetValues $sourceWidget -height]
  437.     set target [VtGetValues $targetWidget -height]
  438.     set diff [expr {($target - $source) / 2}]
  439.  
  440.     VtSetValues $sourceWidget -MOTIF_topOffset $diff
  441. }
  442.  
  443.  
  444. #================================================================== API ===
  445. # VxSetLeftOffsets
  446. #
  447. #       Given a list of widgets which have been created with -alignRight
  448. #    to the previous label, sets the left offset of the first
  449. #    widget so that all the labels fit on the form
  450. #
  451. # Parameters:
  452. #    widgets     - a list of widgets, the first widget in the list is
  453. #              the one that gets modified
  454. #    MOTIFOffset - any MOTIF leftOffset the first widget already has which
  455. #              must be taken into account (OPTIONAL, default=0)
  456. #    CHARMOffset - any CHARM leftOffset the first widget already has which
  457. #              must be taken into account (OPTIONAL, default=0)
  458. # Globals:
  459. # Returns:
  460. #--------------------------------------------------------------------------
  461. proc VxSetLeftOffsets {widgets {MOTIFOffset 0} {CHARMOffset 0}} {
  462.  
  463.     set max 0
  464.     set CHARM_max 0
  465.     set firstWidget [lindex $widgets 0]
  466.  
  467.     # find the widest widget
  468.     for {set i 0} {$i < [llength $widgets]} {incr i} {
  469.         set width [VtGetValues [lindex $widgets $i] -width]
  470.         if {$width > $max} then {
  471.             set max $width
  472.         }
  473.         set CHARM_width [string length [VtGetValues \
  474.             [lindex $widgets $i] -label]]
  475.         if {$CHARM_width > $CHARM_max} then {
  476.             set CHARM_max $CHARM_width
  477.         }
  478.     }
  479.  
  480.     # set the left offset of the first widget
  481.     set diff [expr {$max - [VtGetValues $firstWidget -width] \
  482.         + 1 + $MOTIFOffset}]
  483.  
  484.     VtSetValues $firstWidget -MOTIF_leftOffset $diff
  485.  
  486.     set CHARM_diff [expr {$CHARM_max - [string length [VtGetValues \
  487.                         $firstWidget -label]] \
  488.         + 1 + $CHARMOffset}]
  489.  
  490.     VtSetValues $firstWidget -CHARM_leftOffset $CHARM_diff
  491. }
  492.  
  493.  
  494.  
  495. # ----------------------------------------
  496. # VxAlignedForm
  497. #
  498. #    Description:
  499. #       Creates one or more vertically aligned widgets,
  500. #       with right-justified labels.
  501. #       Each Label and Widget are in their own form.
  502. #       Their widget names may be retrieved as follows:
  503. #
  504. #       (in the list below, $name is the name returned by the
  505. #        VxAlignedForm call, and $n is the position of the widget.
  506. #        "1" is the first widget)
  507. #
  508. #       Form:        VxGetVar $name "form$n"
  509. #       Widget:        VxGetVar $name "widget$n"
  510. #       Label:        VxGetVar $name "label$n"
  511. #
  512. #    Usage:
  513. #       VxAlignedForm widgetName dataList
  514. #
  515. #    Arguments:
  516. #       widgetName      - Name of parent.thisWidget
  517. #       dataList        - A list of lists, each containing a label and
  518. #                         another list containing the desired widget call 
  519. #                         and any desired arguments
  520. #
  521. #    Example:
  522. #       set form [VxAlignedForm $parent.Texts\
  523. #                   { {"The 1st label"  {VtText -columns 30 -value "stuff 1"}}
  524. #                     {"The second label"  {VtText -value "stuff 2"}}
  525. #                     {"3rd label"  {VtText -value "stuff 3"}}
  526. #                     {"Combo"  VtComboBox} } ]
  527. # --------------------
  528. #
  529. proc VxAlignedForm { args } {
  530.     set argc [llength $args]
  531.     if {$argc != 2} {
  532.         error "VxAlignedForm: wrong number of args: $argc"
  533.     }
  534.  
  535.     set wname [lvarpop args]
  536.     set dataList [lvarpop args]
  537.  
  538.     set form [VtForm $wname -marginWidth 0 -marginHeight 0]
  539.  
  540.     set index 0
  541.     set maxWidth 0
  542.     foreach list $dataList {
  543.         # First element is the label
  544.         set labelstr [lindex $list 0]
  545.         # Second element is the widget call and list-o-arguments
  546.         set wlist [lindex $list 1]
  547.         set widgetCall [lvarpop wlist]
  548.  
  549.         incr index
  550.         set tform\
  551.             [VtForm $form.Tform$index\
  552.                 -marginWidth 0\
  553.                 -marginHeight 0\
  554.                 -leftSide FORM\
  555.                 -rightSide FORM]
  556.  
  557.         set label\
  558.             [VtLabel $tform.Label$index\
  559.                 -label $labelstr\
  560.                 -labelRight\
  561.                 -leftSide FORM\
  562.                 -rightSide NONE\
  563.                 -topSide FORM\
  564.                 -bottomSide FORM\
  565.                 -alignLeft NONE]
  566.         set widget [eval $widgetCall $tform.Text$index $wlist]
  567.         VtSetValues $widget\
  568.             -alignLeft NONE\
  569.             -leftSide $label\
  570.             -topSide FORM\
  571.             -bottomSide FORM\
  572.             -rightSide FORM
  573.         set width [VtGetValues $label -width]
  574.         if {$width > $maxWidth} {
  575.             set maxWidth $width
  576.         }
  577.         VxSetVar $form "widget$index" $widget
  578.         VxSetVar $form "label$index" $label
  579.         VxSetVar $form "form$index" $tform
  580.     }
  581.  
  582.     set maxWidth [expr {$maxWidth + 1}]
  583.     for {set i 1} {$i <= $index} {incr i} {
  584.         set label [VxGetVar $form "label$i"]
  585.         set tform [VxGetVar $form "form$i"]
  586.         set width [VtGetValues $label -width]
  587.         if {$width < $maxWidth} {
  588.             set offset [expr {$maxWidth - $width}]
  589.             VtSetValues $tform -leftOffset $offset
  590.         }
  591.     }
  592.  
  593.     return $form
  594. }
  595.  
  596. # ----------------------------------------
  597.  
  598. #@packend
  599.  
  600.  
  601.  
  602. #@package:  VisualTclX-misc VxEndFormCB VxGetShortName
  603.  
  604. #================================================================== API ===
  605. # VxGetShortName
  606. #
  607. #       Given a widget name, strips off all the parent widgets, leaving
  608. #    the short widget name
  609. #
  610. # Parameters:
  611. #    widget - the widget name to strip
  612. # Globals:
  613. # Returns:
  614. #    the stripped widget name
  615. #--------------------------------------------------------------------------
  616. proc VxGetShortName {widget} {
  617.     set wl [split $widget .]
  618.     set wi [expr "[llength $wl] - 1"]
  619.     set short [lindex $wl $wi]
  620.     return $short
  621. }
  622.  
  623. proc VxEndFormCB {cbs} {
  624.     VtDestroyDialog [keylget cbs dialog]
  625. }
  626.  
  627. #@packend
  628.  
  629. #@package: VisualTclX-var VxSetVar VxGetVar VxWidgetVarRef
  630.  
  631. #
  632. # _VxWidgetVarError
  633. #
  634. #   Convert error in error stack to something that makes sense for the
  635. # variable.  This is needed becaused error stacks containing upvared variables
  636. # don't contain the real name.
  637. # 
  638. proc _VxWidgetVarError {msg realVar} {
  639.     global errorInfo errorCode
  640.     regsub {"var"} $msg \"$realVar\" msg
  641.     regsub {"var"} $errorInfo \"$realVar\" errorInfo
  642.     error $msg $errorInfo $errorCode
  643. }
  644.  
  645. #
  646. # VxSetVar
  647. #
  648. #  Set the value of a per-widget variable frame variable.
  649. #
  650. # Parameters:
  651. #   o widgetName (I) - Name of widget that the variable is associated with.
  652. #   o varName (I) - Name of the variable.  May be a scalar or array reference.
  653. #   o value (I) - The value is assigned to the variable
  654. # Returns:
  655. #   Value is returned.
  656. #
  657. proc VxSetVar {widgetName varName value} {
  658.     upvar #0 "VTVars:$widgetName:$varName" var
  659.     
  660.     set stat [catch {
  661.         set result [set var $value]
  662.     } msg]
  663.  
  664.     if {$stat == 1} {
  665.         _VxWidgetVarError $msg $varName
  666.     }
  667.     return $result
  668. }
  669.  
  670. #
  671. # VxGetVar
  672. #
  673. #  Get the value of a per-widget variable frame variable.
  674. #
  675. # Parameters:
  676. #   o widgetName (I) - Name of widget that the variable is associated with.
  677. #   o varName (I) - Name of the variable.  May be a scalar or array reference.
  678. # Returns:
  679. #   Value is returned.
  680. #
  681. proc VxGetVar {widgetName varName} {
  682.     upvar #0 "VTVars:$widgetName:$varName" var
  683.  
  684.     set stat [catch {
  685.         set result [set var]
  686.     } msg]
  687.  
  688.     if {$stat == 1} {
  689.         _VxWidgetVarError $msg $varName
  690.     }
  691.     return $result
  692. }
  693.  
  694. #
  695. # VxWidgetVarRef
  696. #
  697. #   Return a "reference" for per-widget variable frames variable.  This allows
  698. # the variable to be passed by reference to other Tcl commands. eg:
  699. #
  700. #    array names [VxWidgetVarRef my.widget.path data]
  701. #
  702. # Parameters:
  703. #   o widgetName (I) - Name of widget that the variable is associated with.
  704. #   o varName (I) - Name of the variable.  May be a scalar or array, but not
  705. #     an element of the arrray.
  706. # Returns:
  707. #   A reference to the variable usable in the current scope.
  708. #
  709. proc VxWidgetVarRef {widgetName varName} {
  710.     set ref "VTVars:$widgetName:$varName"
  711.     uplevel global $ref
  712.     return $ref
  713. }
  714.  
  715.  
  716. #@package: VisualTclX-SpinButton VxSpinButton VxSpinButtonSetMinValue \
  717.     VxSpinButtonSetMaxValue 
  718.  
  719. #================================================================== INT ===
  720. #  SB:CheckBoundsCB
  721. #       Checks the text field value is within the upper and lower bounds.
  722. # Parameters:
  723. #    instance  - the widget name of the enclosing form of the SpinButton
  724. #    underCB   - a callback for when the value goes below the lower
  725. #            bound.  If set to null, wraps the value around.
  726. #    overCB    - a callback for when the value goes over the upper
  727. #            bound.  If set to null, wraps the value around.
  728. # Globals:
  729. #    SBlower     - array of lower value boundary values, indexed by
  730. #              instance
  731. #    SBupper     - array of upper value boundary values, indexed by
  732. #              instance
  733. # Returns:
  734. #--------------------------------------------------------------------------
  735. proc SB:CheckBoundsCB {instance underCB overCB cbs} {
  736.  
  737.     global SBlower SBupper 
  738.  
  739.     set field [VxGetVar $instance text]
  740.     set newValue [VtGetValues $field -value] 
  741.  
  742.     if {![ctype digit $newValue]} then {
  743.            VtSetValues $field -value $SBlower($instance)
  744.         return
  745.     }
  746.  
  747.         if {$newValue > $SBupper($instance)} then {
  748.         if {[string length $overCB]==0} then {
  749.                VtSetValues $field -value $SBupper($instance)
  750.             return
  751.         } else {
  752.             $overCB $cbs
  753.             return
  754.         }
  755.     }
  756.     
  757.         if {$newValue < $SBlower($instance)} then {
  758.         if {[string length $underCB]==0} then {
  759.                VtSetValues $field -value $SBlower($instance)
  760.             return
  761.         } else {
  762.             $underCB $cbs
  763.             return
  764.         }
  765.         }
  766.  
  767. } ;# SB:CheckBoundsCB
  768.  
  769.  
  770. #================================================================== INT ===
  771. #  SB:ChangeValueCB
  772. #       Increases or decreases the SpinButton value, wrapping the value
  773. #    around upper and lower bounds.
  774. # Parameters:
  775. #    instance  - the widget name of the enclosing form of the SpinButton
  776. #    underCB   - a callback for when the value goes below the lower
  777. #            bound.  If set to null, wraps the value around.
  778. #    overCB    - a callback for when the value goes over the upper
  779. #            bound.  If set to null, wraps the value around.
  780. #    increment - how much to increase/decrease the value by
  781. #    direction - up: increase the value, down: decrease the value
  782. #    upOp      - operation to perform on increment when the "up" button
  783. #            is pressed 
  784. #    dnOp      - operation to perform on increment when the "down" button
  785. #            is pressed 
  786. # Globals:
  787. #    SBlower     - array of lower value boundary values, indexed by
  788. #              instance
  789. #    SBupper     - array of upper value boundary values, indexed by
  790. #              instance
  791. # Returns:
  792. #--------------------------------------------------------------------------
  793. proc SB:ChangeValueCB {instance underCB overCB increment \
  794.                direction upOp dnOp cbs} {
  795.  
  796.     global SBlower SBupper 
  797.  
  798.     set field [VxGetVar $instance text]
  799.  
  800.     set currentValue [VtGetValues $field -value]
  801.     if {[string length $currentValue] == 0} then {
  802.         set currentValue $SBlower($instance)
  803.         }
  804.         if {[ctype digit $currentValue] == 0} then {
  805.         set currentValue $SBlower($instance)
  806.         }
  807.  
  808.         if {$direction == "up"} {
  809.             set newValue [expr "$currentValue $upOp $increment"]
  810.         } else {
  811.             set newValue [expr "$currentValue $dnOp $increment"]
  812.         }
  813.     
  814.         if {$newValue>$SBupper($instance)} then {
  815.         if {[string length $overCB]==0} then {
  816.                 if {$direction == "up"} {
  817.                 set newValue $SBlower($instance)
  818.             } else {
  819.                 set newValue $SBupper($instance)
  820.             }
  821.         } else {
  822.             $overCB $cbs
  823.             return
  824.         }
  825.     }
  826.     
  827.         if {$newValue<$SBlower($instance)} then {
  828.         if {[string length $underCB]==0} then {
  829.                 if {$direction == "up"} {
  830.                 set newValue $SBlower($instance)
  831.             } else {
  832.                 set newValue $SBupper($instance)
  833.             }
  834.         } else {
  835.             $underCB $cbs
  836.             return
  837.         }
  838.         }
  839.  
  840.        VtSetValues $field -value $newValue
  841.  
  842. } ;# SB:ChangeValueCB
  843.  
  844.  
  845. #================================================================== EXT ===
  846. # VxSpinButtonSetMinValue
  847. #       Sets the lower boundary for a spin button
  848. # Parameters:
  849. #    instance  - the instance name of the SpinButton
  850. #    lower     - the lower value boundary
  851. # Globals:
  852. #    SBlower     - array of lower value boundary values, indexed by
  853. #              instance
  854. # Returns:
  855. #--------------------------------------------------------------------------
  856. proc VxSpinButtonSetMinValue {instance lower} {
  857.     global SBlower 
  858.  
  859.     set SBlower($instance) $lower
  860.  
  861.     set textW [VxGetVar $instance text]
  862.  
  863.     set currentValue [VtGetValues $textW -value]
  864.     if {[string length $currentValue] == 0} then {
  865.         set currentValue $SBlower($instance)
  866.         }
  867.         if {[ctype digit $currentValue] == 0} then {
  868.         set currentValue $SBlower($instance)
  869.         }
  870.  
  871.     if {$currentValue < $SBlower($instance)} then {
  872.         set currentValue $SBlower($instance)
  873.     }
  874.  
  875.     VtSetValues $textW -value $currentValue
  876.  
  877. } ;# VxSpinButtonSetMinValue
  878.  
  879.  
  880. #================================================================== EXT ===
  881. # VxSpinButtonSetMaxValue
  882. #       Sets the upper boundary for a spin button
  883. # Parameters:
  884. #    instance  - the instance name of the SpinButton
  885. #    upper     - the upper value boundary
  886. # Globals:
  887. #    SBupper     - array of upper value boundary values, indexed by
  888. #              instance
  889. # Returns:
  890. #--------------------------------------------------------------------------
  891. proc VxSpinButtonSetMaxValue {instance upper} {
  892.     global SBupper 
  893.  
  894.     set SBupper($instance) $upper
  895.  
  896.     set textW [VxGetVar $instance text]
  897.  
  898.     set currentValue [VtGetValues $textW -value]
  899.     if {[string length $currentValue] == 0} then {
  900.         set currentValue $SBlower($instance)
  901.         }
  902.         if {[ctype digit $currentValue] == 0} then {
  903.         set currentValue $SBlower($instance)
  904.         }
  905.  
  906.     if {$currentValue > $SBupper($instance)} then {
  907.         set currentValue $SBupper($instance)
  908.     }
  909.  
  910.     VtSetValues $textW -value $currentValue
  911.  
  912. } ;# VxSpinButtonSetMaxValue
  913.  
  914.  
  915. #================================================================== EXT ===
  916. # getPixmapDirectory
  917. #       Returns the location of the Visual Tcl pixmap directory.
  918. # Parameters:
  919. #       NONE
  920. #
  921. proc getPixmapDirectory {} {
  922.     global env
  923.     if {[info exists env(VTCL_HOME)]} {
  924.         set pixmapDir "$env(VTCL_HOME)/pixmaps"
  925.     } else {
  926.         if {[info exists env(WSHOMEDIR)]} {
  927.             set pixmapDir "$env(WSHOMEDIR)/pixmaps"
  928.             } else {
  929.             set pixmapDir "/lib/vtcl/pixmaps"
  930.         }
  931.     }
  932.     return $pixmapDir
  933. }
  934.  
  935.  
  936. #================================================================== EXT ===
  937. # VxSpinButton
  938. #       Creates a SpinButton, which consists of a text field and two
  939. #    buttons which increase and decrease the numeric value in the text
  940. #    field within upper and lower bounds.
  941. # Parameters:
  942. #    widget    - the widget name of this SpinButton
  943. #    width     - the width of the Text widget
  944. #    lower     - the lower boundary value 
  945. #    underCB   - a callback for when the value goes below the lower
  946. #            bound.  If set to "", the package automatically wraps the
  947. #            value around to the upper value.
  948. #    upper     - the upper boundary value
  949. #    overCB    - a callback for when the value goes over the upper
  950. #            bound.  If set to "", the package automatically wraps the
  951. #            value around to the lower value.
  952. #    increment - how much to increase/decrease the value by
  953. #    default   - the inital default value
  954. #    userCB    - a callback which checks the value of the Text widget, or ""
  955. #            for no callback
  956. #    position  - standard geometryArgs for the Text widget.
  957. #    upOp (OPT)- operation to perform on increment when the "up" button
  958. #            is pressed (+ if not present)
  959. #    dnOp (OPT)- operation to perform on increment when the "down" button
  960. #            is pressed (- if not present)
  961. # Globals:
  962. #    SBlower     - array of lower boundary values, indexed by widget
  963. #    SBupper     - array of upper boundary values, indexed by widget
  964. # Returns:
  965. #    The name of the enclosing form widget
  966. # Notes:
  967. #    Attached to the form widget returned, is the name of the text widget
  968. #    and rowcol widget containing the buttons:
  969. #
  970. #    VxGetVar $sb text     for the text widget
  971. #    VxGetVar $sb rowcol   for the rowcol widget
  972. #--------------------------------------------------------------------------
  973. proc VxSpinButton {widget width lower underCB upper overCB \
  974.                increment default userCB position \
  975.                {upOp "+"} {dnOp "-"}} {
  976.  
  977.     global SBlower SBupper
  978.  
  979.         
  980.     #set iconPath /usr/lib/X11/sco/ScoAdmin/common
  981.         set iconPath [getPixmapDirectory]
  982.  
  983.     set SB [eval VtForm $widget -marginHeight 0 -marginWidth 0 $position]
  984.  
  985.     if {$userCB != ""} then {
  986.         set text [VtText $SB.text -rows 1 -columns $width \
  987.             -value $default -callback $userCB \
  988.             -leftSide FORM -topSide FORM -bottomSide FORM \
  989.             -MOTIF_topOffset 2 -MOTIF_bottomOffset 4 ]
  990.     } else {
  991.         set text [VtText $SB.text -rows 1 -columns $width \
  992.             -value $default \
  993.             -callback "SB:CheckBoundsCB $SB \"$underCB\" \"$overCB\""\
  994.             -leftSide FORM -topSide FORM -bottomSide FORM \
  995.             -MOTIF_topOffset 2 -MOTIF_bottomOffset 4 ]
  996.     }
  997.  
  998.     set SBlower($SB) $lower
  999.     set SBupper($SB) $upper
  1000.  
  1001.     if {! [VtInfo -charm]} then {
  1002.         set rowcol [VtRowColumn $SB.rc -packing TIGHT -spacing 0 \
  1003.         -leftOffset 0 -leftSide NONE -topSide FORM -rightSide FORM \
  1004.         -bottomSide FORM -xmArgs {XmNmarginHeight 0 XmNmarginWidth 0}]
  1005.  
  1006.         VtSetValues $text -rightSide $rowcol \
  1007.                   -rightOffset 0
  1008.  
  1009.         set upBut [VtPushButton $rowcol.up \
  1010.             -pixmap $iconPath/up_ptr.xbm \
  1011.             -callback "SB:ChangeValueCB $SB {$underCB} \
  1012.                   {$overCB} $increment up $upOp $dnOp" \
  1013.                 -label "^"]
  1014.  
  1015.         set downBut [VtPushButton $rowcol.down \
  1016.             -pixmap $iconPath/down_ptr.xbm \
  1017.             -callback "SB:ChangeValueCB $SB {$underCB} \
  1018.                   {$overCB} $increment down $dnOp $dnOp" \
  1019.                 -label "v"]
  1020.  
  1021.         VxSetVar $SB rowcol  $rowcol
  1022.         VxSetVar $SB upBut   $upBut
  1023.         VxSetVar $SB downBut $downBut
  1024.     } else {
  1025.         VtSetValues $text -rightSide FORM
  1026.     }
  1027.  
  1028.     VxSetVar $SB text    $text
  1029.  
  1030.     return $SB
  1031.  
  1032. } ;# VxSpinButton
  1033.  
  1034. #@packend
  1035.  
  1036.  
  1037.  
  1038. #@package: VisualTclX-backwardsCompat WxMenu WxMenuGetButton WxOptionMenu \
  1039.     WxOptionMenuGetSelected WxOptionMenuReplaceOptions WxOptionMenuSetSelected \
  1040.     WxList WxText WxRowColumn WxRadioBox WxCheckBox WxComboBox \
  1041.     WxAlignBaseLines WxCenterVertically WxSetLeftOffsets WxAlignedForm \
  1042.     WxEndFormCB WxGetShortName WxSetVar WxGetVar WxWidgetVarRef WxSpinButton \
  1043.     WxSpinButtonSetMinValue WxSpinButtonSetMaxValue 
  1044.  
  1045. proc WxMenu {dlog menubar menuList defaultCB} {
  1046.     return [VxMenu $dlog $menubar $menuList $defaultCB]
  1047. }
  1048.  
  1049. proc WxMenuGetButton {dlog name} {
  1050.     return [VxMenuGetButton $dlog $name]
  1051. }
  1052.  
  1053. proc WxOptionMenu {name label options CB selection} {
  1054.     return [VxOptionMenu $name $label $options $CB $selection]
  1055. }
  1056.  
  1057. proc WxOptionMenuGetSelected {menu} {
  1058.     return [VxOptionMenuGetSelected $menu]
  1059. }
  1060.  
  1061. proc WxOptionMenuSetSelected {menu selected} {
  1062.     return [VxOptionMenuSetSelected $menu $selected]
  1063. }
  1064.  
  1065. proc WxOptionMenuReplaceOptions {menu options selection} {
  1066.     return [VxOptionMenuReplaceOptions $menu $options $selection]
  1067. }
  1068.  
  1069. proc WxList {name args} {
  1070.     return [eval "VxList \"$name\" $args"]
  1071. }
  1072.  
  1073. proc WxText {name args} {
  1074.     return [eval "VxText \"$name\" $args"]
  1075. }
  1076.  
  1077. proc WxRadioBox {name args} {
  1078.     return [eval "VxRadioBox \"$name\" $args"]
  1079. }
  1080.  
  1081. proc WxCheckBox {name args} {
  1082.     return [eval "VxCheckBox \"$name\" $args"]
  1083. }
  1084.  
  1085. proc WxRowColumn {name args} {
  1086.     return [eval "VxRowColumn \"$name\" $args"]
  1087. }
  1088.  
  1089. proc WxComboBox {name args} {
  1090.     return [eval "VxComboBox \"$name\" $args"]
  1091. }
  1092.  
  1093. proc WxAlignBaseLines {targetWidget sourceWidget {currentOffset 0}} {
  1094.     return [VxAlignBaseLines $targetWidget $sourceWidget $currentOffset]
  1095. }
  1096.  
  1097. proc WxCenterVertically {targetWidget sourceWidget} {
  1098.     return [VxCenterVertically $targetWidget $sourceWidget]
  1099. }
  1100.  
  1101. proc WxSetLeftOffsets {widgets {MOTIFOffset 0} {CHARMOffset 0}} {
  1102.     return [VxSetLeftOffsets $widgets $MOTIFOffset $CHARMOffset]
  1103. }
  1104.  
  1105. proc WxAlignedForm {args} {
  1106.     return [eval "VxAlignedForm $args"]
  1107. }
  1108.  
  1109. proc WxGetShortName {widget} {
  1110.     return [VxGetShortName $widget]
  1111. }
  1112.  
  1113. proc WxEndFormCB {cbs} {
  1114.     return [VxEndFormCB $cbs]
  1115. }
  1116.  
  1117. proc WxSetVar {widgetName varName value} {
  1118.     return [VxSetVar $widgetName $varName $value]
  1119. }
  1120.  
  1121. proc WxGetVar {widgetName varName} {
  1122.     return [VxGetVar $widgetName $varName]
  1123. }
  1124.  
  1125. proc WxWidgetVarRef {widgetName varName} {
  1126.     return [VxWidgetVarRef $widgetName $varName]
  1127. }
  1128.  
  1129. proc WxSpinButtonSetMinValue {instance lower} {
  1130.     return [VxSpinButtonSetMinValue $instance $lower]
  1131. }
  1132.  
  1133. proc WxSpinButtonSetMaxValue {instance upper} {
  1134.     return [VxSpinButtonSetMaxValue $instance $upper]
  1135. }
  1136.  
  1137. proc WxSpinButton {widget width lower underCB upper overCB \
  1138.                increment default userCB position \
  1139.                {upOp "+"} {dnOp "-"}} {
  1140.     return [VxSpinButton $widget $width $lower $underCB $upper $overCB \
  1141.             $increment $default $userCB $position $upOp $dnOp]
  1142. }
  1143.